Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue33/intrposr/ipunit2.pas

Pascal/Delphi Source File | 1998-03-04 | 14.1 KB | 472 lines

unit ipunit2;
//////////////////////////////////////////////////////////////////
//
// Demonstration unit for using Interposer Classes to add functionality
// to the TForm class.
//
// ⌐Stephen Posey -- [e-mail]
// Written for The Delphi Magazine
//
//////////////////////////////////////////////////////////////////
// References:
// The code for drawing the gradient title bar
// is adapted from C++ Builder code in:
//    Miano, J.; Cabanski, T.; & Howe, H. (1997).
//    The Waite Group's Borland C++ Builder How-To.
//    Corte Madera, California, USA: Waite Group Press.
//    ISBN: 1-57169-109-X.
//
// The code for accepting Drag and Drop from File Manager/Explorer
// is adapted from code in
//    Rubenking, N. (1996).
//    Delphi Programming Problem Solver.
//    Foster City, California, USA: IDG Books.
//    ISBN: 1-56884-795-5
//
// The code to make the Enter Key "Tab" among controls
// is adapted from code in
//    Frerking, G.; Wallace, N.; & Niddery, W. (1995).
//    The Waite Group's Borland Delphi How-To.
//    Corte Madera, California, USA: Waite Group Press.
//    ISBN: 1-57169-019-0.



interface

uses
  Windows, Messages, SysUtils, ShellAPI, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls;

type

  TForm = class(Forms.TForm)
  // TForm "Interposer" Class adding features to the basic TForm
  // including:
  //   1) a custom gradient filled caption bar
  //   2) a simple "About Box"
  //   3) Enter key processing
  //   4) Accepting Drag and Drop from File Manager/Explorer

  // This interposer form class could be placed into its own unit so it
  // could act as ancestor for many form; the new unit name would just
  // have to appear AFTER the Forms unit in this forms "uses" clause
  private
  // Support fields for Custom TitleBar drawing
    WindowCanvas : TCanvas ;
    TitleBarRect : TRect ;
    FinalCaptionColor : TColor ;
    FinalRedIntensity,
    FinalGreenIntensity,
    FinalBlueIntensity : byte ;
    IsNT35 : boolean ;

  // Enter key acts like Tab?
    FEnterTab : boolean ;

  protected
  // Support routines for custom title bar drawing
    function CanDrawCustomTitleBar : boolean ;
    procedure CalculateTitleBarRect ;
    procedure DrawGradient ;
    procedure DrawIcon ;
    procedure DrawCaptionString ;

  // Support routines for Drag and Drop
    procedure ProcessDragDrop( Drop: THandle ; Min : boolean ) ;
    procedure DragDropFileAction( FileName : string ; where : TPoint ) ; virtual ;

  // Message Handlers
    procedure WMNCActivate( var Msg : TWMNCActivate ) ;
      message WM_NCACTIVATE ;

    procedure WMNCPaint( var Msg : TMessage ) ;
      message WM_NCPAINT ;

    procedure WMDropFiles( var Msg : TWMDropFiles ) ;
      message WM_DROPFILES ;

  // Overridden methods
    constructor Create(AOwner: TComponent); override;
    destructor Destroy ; override ;
    procedure Resize ; override ;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override ;

  public
    procedure AboutBox ;

  published
    // Ideally this property would appear in the Object
    // Inspector, but this technique doesn't support that
    property EnterTab : boolean
      read FEnterTab
      write FEnterTab ;
  end ;

type
  TDemoForm = class(TForm)  // ancestor is Interposer TForm!
    Button1: TButton;
    ListBox1: TListBox;
    Edit1: TEdit;
    Edit2: TEdit;
    Button2: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure DragDropFileAction( FileName : string ; Where : TPoint ) ; override ;
  end;

var
  DemoForm: TDemoForm;

implementation

{$R *.DFM}

procedure GetTitleBarFont( TheFont : TFont  ) ;
var
  TNCM: TNonClientMetrics ;
begin
  TNCM.cbSize := SizeOf( TNonClientMetrics ) ;
  SystemParametersInfo( SPI_GETNONCLIENTMETRICS, 0, @TNCM, 0 ) ;
  TheFont.Handle := CreateFontIndirect( TNCM.lfCaptionFont ) ;
end;

function GetTitleBarFontColor( IsActive : boolean ) : TColor ;
begin
  if IsActive then
    Result :=  TColor ( GetSysColor( COLOR_CAPTIONTEXT    ))
  else
    Result :=  TColor ( GetSysColor( COLOR_INACTIVECAPTIONTEXT    )) ;
end;

//
// Interposer TForm's Support routines for Drag and Drop
//
procedure TForm.ProcessDragDrop( Drop: THandle ; Min : boolean ) ;
// generic Drag and Drop processing loop
var
  j : word ;
  Buffer : array [0..255] of char ;
  TP : TPoint ;
begin
  DragQueryPoint( Drop, TP ) ;                  // get position of drop
  for j := 0 to DragQueryFile( Drop, Cardinal( -1 ), nil, 255 ) - 1 do
  begin
    DragQueryFile( Drop, j, Buffer, 80 ) ;        // get next dropped filename
    DragDropFileAction( StrPas( Buffer ), TP ) ;  // Call overridden Drag Drop processor method
  end { for } ;
  DragFinish( Drop ) ;
end;

procedure TForm.DragDropFileAction( FileName : string ; where : TPoint ) ;
// virtual do-nothing place holder for descendants' processing of
// Dropped filenames
begin
  //Do nothing
  Exit ;
end;

//
// Interposer TForm's Support routines for custom title bar drawing
//
function TForm.CanDrawCustomTitleBar : boolean ;
// Sometimes don't want to perform the gradient fill, this
// encapsulates those situations
begin
  if ( WindowCanvas = nil )       // WMNCPaint might be called AFTER destructor
    or (not Application.Active)   // WM_NCPAINT mesage may arrive when form is inactive
    or (Width < 150)              // Gradient looks poor at very small widths
    or (IsNT35)                   // NT 3.5 uses Win3 interface, would require
                                  // special alternate processing, not provided here
  then
  begin
    Result := FALSE ;
    Exit ;
  end;

  // Gradient looks poor if it's from black to a very light color.
  // Word (e.g.) actually shades from White instead of Black for
  // light caption colors.  Here we just don't shade for light colors.
  FinalCaptionColor := TColor( GetSysColor( COLOR_ACTIVECAPTION )) ;
  FinalRedIntensity   := GetRValue( FinalCaptionColor ) ;
  FinalGreenIntensity := GetGValue( FinalCaptionColor ) ;
  FinalBlueIntensity  := GetBValue( FinalCaptionColor ) ;

  // Is at least on of the RGB values in the dark range (< 128)?
  // If not, don't draw gradient
  if (FinalRedIntensity < 128)
    or (FinalGreenIntensity < 128)
    or (FinalBlueIntensity < 128)
  then
    Result := TRUE
  else
    Result := FALSE ;
end;

procedure TForm.CalculateTitleBarRect ;
// Determine dimensions of titlebar area
// The Left, Top, and Bottom must be calculate precisely
// The right value is arbitrary, but meant to be large enough
// to avoid the Min/Max/Exit buttons
begin
  TitleBarRect := Rect(
    GetSystemMetrics(SM_CXFRAME),
    GetSystemMetrics(SM_CYFRAME),
    Width - 4 * GetSystemMetrics(SM_CXSIZE),  // stay away from Min/Max/Exit btns.
    GetSystemMetrics(SM_CXFRAME) + GetSystemMetrics(SM_CYCAPTION) - 1
  ) ;
end;

procedure TForm.DrawGradient ;
// Gradient shading involves gradually increasing RGB color values from
// 0 (black) to the final RGB value of the caption color.  The increment
// values are multiplied by 0, 1..31 to create 32 shades.
// The Final<RGB>Intensity values are calculated in CanDrawCustomTitleBar.
var
  RedIncrement, GreenIncrement, BlueIncrement, SectionWidth  : byte ;
  Section : TRect ;
  FillColor : TColor ;
  j : integer ;
begin
  // Maximum intensity is 255,
  // adding 1 makes Final<RGB>Intensity evenly divisible by 32.
  RedIncrement   := ( FinalRedIntensity   + 1 ) div 32 ;
  GreenIncrement := ( FinalGreenIntensity + 1 ) div 32 ;
  BlueIncrement  := ( FinalBlueIntensity  + 1 ) div 32 ;

  Section := TitleBarRect ;
  // Section width is the width of each gradient "section".
  // Titlebar will contain 36 gradient sections, 5 will be Black
  // on the right to account for the Min/Max/Exit buttons.
  // The remaining 31 sections will shade between Black and the
  // titlebar color.
  SectionWidth := ( TitleBarRect.Right - TitleBarRect.Left ) div 36 ;

  FillColor := clBlack ;

  Section.Right := Section.Left + 5 * SectionWidth ;  // 5 sections of black

  // configure the brush
  WindowCanvas.Brush.Color := FillColor ;
  WindowCanvas.Brush.Style := bsSolid ;

  // fill in the black sections
  WindowCanvas.FillRect( Section ) ;

  // move section over
  Section.Left := Section.Left + ( 5 * SectionWidth ) ;

  for j := 1 to 31 do    //iterate through shades between Black and TitleBar color
  begin
    Section.Right := Section.Left + SectionWidth ;  // size the section
    // set the brush color and fill the section
    FillColor := RGB( RedIncrement * j, GreenIncrement * j, BlueIncrement * j ) ;
    WindowCanvas.Brush.Color := FillColor ;
    WindowCanvas.FillRect( Section ) ;

    Section.Left := Section.Left + SectionWidth ;  // shift section over
  end { for };
end;

procedure TForm.DrawIcon ;
// Redraw the System Menu button because the gradient drawing just painted
// over it with Black.
var
  IconWidth, IconHeight : integer ;
  Section : TRect ;
begin
  // Width and height of "small icon"
  IconWidth := GetSystemMetrics( SM_CXSMICON ) ;
  IconHeight := GetSystemMetrics( SM_CYSMICON ) ;

  // where does System Menu button fit?
  Section := Rect(
    TitleBarRect.Left + 2,
    TitleBarRect.Top + 1,
    TitleBarRect.Left + IconWidth,
    TitleBarRect.Top + IconHeight
  ) ;

  // Redraw the button
  DrawIconEx( WindowCanvas.Handle, Section.Left, Section.Top,
    Application.Icon.Handle,IconWidth, IconHeight, 0, 0, DI_NORMAL ) ;
end;

procedure TForm.DrawCaptionString ;
// Redraw Caption string.  Working with a Temporary copy of the
// Caption from the Caption property avoids flicker.
var
  R : TRect ;
  TempCap : string ;
begin
  // Area of TitleBar for caption
  R := Rect( TitleBarRect.Left + 2 + 16 + 4, TitleBarRect.Top,
    TitleBarRect.Right - 20, TitleBarRect.Bottom ) ;

  TempCap := Caption ;

  // Transparent mode so text doesn't wipe out Gradient
  SetBKMode( WindowCanvas.Handle, TRANSPARENT ) ;

  // Get info on title bar font (Face, Color, Style, etc.) from system
  GetTitleBarFont( WindowCanvas.Font ) ;
  WindowCanvas.Font.Color := GetTitleBarFontColor( Active ) ;

  // Redraw the caption
  DrawText( WindowCanvas.Handle, PChar( TempCap ), Length( Caption ),
    R, DT_SINGLELINE or DT_VCENTER ) ;
end;

//
// Interposer TForm's Message Handlers
//
procedure TForm.WMDropFiles( var Msg : TWMDropFiles ) ;
begin
  ProcessDragDrop( Msg.Drop, FALSE ) ;
  Msg.Result := 0 ;
end;

procedure TForm.WMNCActivate( var Msg : TWMNCActivate ) ;
var
  PaintMsg : TMessage ;
begin
  Msg.Result := Cardinal( TRUE ) ;  // always handle this message
  if not Msg.Active then            // If form inactive do default drawing
  begin
    DefWindowProc( Handle, Msg.Msg, LongInt( Msg.Active ), 0 ) ;
    // Code for inactive titlebar drawing may be added here
    // Example leaves inactive caption at default appearance
    Exit ;
  end;

  // if Active window, do WMNCPaint
  PaintMsg.Msg := Msg.Msg ;                   // build message
  PaintMsg.WParam := LongInt( Msg.Active ) ;
  WMNCPaint( PaintMsg ) ;                     // call it
end;

procedure TForm.WMNCPaint( var Msg : TMessage ) ;
var
  WindowDC : HDC ;
begin
  // Use default processing to draw min/max/close buttons, menu, and the
  // frame.  The caption bar is drawn too, but we paint over that later.
  DefWindowProc( Handle, Msg.Msg, Msg.WParam, Msg.LParam ) ;

  // check for any reason not to draw the custom caption
  if CanDrawCustomTitleBar = FALSE then
    Exit ;

  // Create a DC for the entire form window, then assign
  // the handle to the window canvas
  WindowDC := GetWindowDC( Handle ) ;
  WindowCanvas.Handle := WindowDC ;

  CalculateTitleBarRect ;        // calculate dimensions of titlebar
  DrawGradient ;                 // draw gradient fill
  DrawIcon ;                     // redraw system menu button
  DrawCaptionString ;            // draw the caption

  ReleaseDC( Handle, WindowDC ) ; // free resources
  WindowCanvas.Handle := 0 ;
end;

//
// Interposer TForm's Overridden methods
//
constructor TForm.Create( AOwner : TComponent ) ;
var
  Ver : TOSVersionInfo ;
begin
  inherited Create( AOwner ) ;
  // Drag and Drop processing Setup
  DragAcceptFiles( Handle, TRUE ) ;

  // custom title bar drawing setup
  WindowCanvas := TCanvas.Create ;

  // NT 3.5 uses Win 3.1 interface, needs custom handling
  Ver.dwOSVersionInfoSize := SizeOf(TOSVersionInfo) ;
  GetVersionEx( Ver ) ;
  if ( Ver.dwMajorVersion < 4 ) then
    IsNT35 := TRUE
  else
    IsNT35 := FALSE ;

  // Default to normal Enter key behavior
  FEnterTab := FALSE ;
end;

destructor TForm.Destroy ;
begin
  WindowCanvas.Free ;
  WindowCanvas := nil ;
  inherited Destroy ;
end;

procedure TForm.Resize ;
begin
  inherited Resize ;
  Perform( WM_NCPAINT, 1, 0 ) ;
end;

procedure TForm.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if FEnterTab then
  if Key = VK_RETURN then
  begin
    Key := 0 ;
    if not ( ssShift in Shift ) then
      Perform( WM_NEXTDLGCTL, 0, 0 )
    else
      Perform( WM_NEXTDLGCTL, 1, 0 ) ;
  end ;
  inherited KeyDown( Key, Shift ) ;
end;

procedure TForm.AboutBox ;
// Simple About box
begin
  MessageBeep( MB_ICONEXCLAMATION ) ;
  MessageBox( Handle, 'TForm Interposer Class Demonstration', 'About...',
    MB_OK or MB_ICONEXCLAMATION or MB_TASKMODAL ) ;
end;


//
// descendant DemoForm's Methods
//
procedure TDemoForm.Button1Click(Sender: TObject);
begin
  AboutBox ;
end;

procedure TDemoForm.DragDropFileAction( FileName : string ; Where : TPoint ) ;
// Descendant method for DragDrop action
begin
  ListBox1.Items.Add( Format( '%s dropped at (%d, %d)', [FileName, Where.X, Where.Y] )) ;
end;

procedure TDemoForm.Button2Click(Sender: TObject);
begin
  Close ;
  Application.Terminate ;
end;

procedure TDemoForm.FormShow(Sender: TObject);
begin
  EnterTab := TRUE ;
end;

end.